home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / NEETVGA / RGB / GRAPHICS.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-02  |  2KB  |  123 lines
  1. program graphicstest;
  2. uses
  3.    crt,
  4.    graph,fsupvga,
  5.    fernrogr,
  6.    fernando,roger;
  7. const
  8.    intensity:byte=100;
  9.  
  10. procedure pause;
  11. var
  12.    buff:char;
  13. begin
  14.    repeat until keypressed;
  15.    buff:=readkey;
  16. end;
  17.  
  18. procedure clearpalette;
  19. var
  20.    a:byte;
  21.    palette:fullpalette;
  22. begin
  23.    for a:=0 to 255 do
  24.       with palette[a] do begin
  25.          red:=0;
  26.          green:=0;
  27.          blue:=0;
  28.       end;
  29.    restorefullpalette(palette);
  30. end;
  31.  
  32. procedure worker;
  33. type
  34.    coloring=byte;
  35. var
  36.    a:coloring;
  37.    b:integer;
  38. begin
  39.    a:=random(229)+1;
  40.    for b:=0 to getmaxx do begin
  41.       inc(a);
  42.       if a>=231 then a:=1;
  43.       setcolor(a);
  44.       line(b,0,b,getmaxy);
  45.    end;
  46. end;
  47.  
  48. procedure working;
  49. var
  50.    a,b:byte;
  51.    color:prgb;
  52.    pal1,pal2,pal3:crgb;
  53. function well(a:byte):byte;
  54. begin
  55.    well:=trunc((a*100)/230);
  56. end;
  57. begin
  58.    a:=0;
  59.    for color:=R to pred(pred(W)) do begin
  60.       getcolr(color,pal1,intensity);
  61.       getcolr(succ(color),pal2,intensity);
  62.       for b:=0 to blendframes do begin
  63.          inc(a);
  64.          incrementer(pal1,pal2,b,pal3);
  65.          pal3.color:=a;
  66.          putpalettecolor(pal3);
  67.       end;
  68.    end;
  69. end;
  70.  
  71. procedure followaround;
  72. var
  73.    bx,by:integer;
  74.    x,y:integer;
  75.    stop:boolean;
  76.    tempc:char;
  77.    pal:crgb;
  78. begin
  79.    bx:=1;  x:=1;  by:=1;  y:=1;
  80.    stop:=false;
  81.    repeat
  82.       repeat
  83.          tempc:=readkey;
  84.       until tempc in [#27,'2','4','6','8'];
  85.       case tempc of
  86.          '2': if y<getmaxy-1 then inc(y) else y:=0;
  87.          '4': if x>0 then dec(x) else x:=getmaxx;
  88.          '6': if x<getmaxx then inc(x) else x:=1;
  89.          '8': if y>0 then dec(y) else y:=getmaxy-1;
  90.          #27: stop:=true;
  91.       end;
  92.  
  93.       putpixel(bx,by,getpixel(bx,by+1));
  94.       getpalettecolor(getpixel(x,y),pal);
  95.       with pal do
  96.          putcolor(255,ginverse(red),ginverse(green),ginverse(blue));
  97.       putpixel(x,y,255);
  98.       bx:=x;  by:=y;
  99.    until stop;
  100. end;
  101.  
  102. procedure control;
  103. var
  104.    originalpalette:fullpalette;
  105. begin
  106.    storefullpalette(originalpalette);
  107.  
  108.    blendframes:=9;
  109.  
  110.  
  111.    initializesupvga(1,'c:\tp\bgi');
  112.    clearpalette;
  113.    worker;
  114.    working;
  115.    followaround;
  116.    pause;
  117.    restorefullpalette(originalpalette);
  118. end;
  119.  
  120. begin
  121.    control;
  122. end.
  123.